
{***********************************************************}
{                                                           }
{      Luxena Class Library                                 }
{                                                           }
{      Resource Pooling                                     }
{                                                           }
{      Copyright (c) 2001-2008 Luxena Software Company      }
{      http://www.luxena.com                                }
{      e-mail: support@luxena.com                           }
{                                                           }
{***********************************************************}

unit LXResourcePool;

{$I lx.inc}

interface

uses
  Windows, SysUtils, Classes, SyncObjs;

const

{ Property Default Values }

  LX_DEFAULT_POOL_ENABLED = False;
  LX_DEFAULT_POOL_MIN = 1;
  LX_DEFAULT_POOL_MAX = 5;
  LX_DEFAULT_POOL_TIME_OUT = 15000;
  LX_DEFAULT_POOL_LIFE_TIME = 5000;
  LX_DEFAULT_POOL_MAX_TIME = 0;


type

{ ELXResourceException }

  ELXResourceException = class(Exception);


{ TLXResource }

  TLXResource = class
  public
    procedure Acquire(const Params: array of const); virtual; abstract;
    procedure Release; virtual; abstract;
  end;


{ TLXResourceCollector }

  TLXResourceCollector = class
  public
    procedure CollectResource; virtual; abstract;
  end;


{ TLXResourcePoolOptions }

  TLXResourcePoolOptions = class(TPersistent)
  private
    FEnabled: Boolean;
    FMin: Cardinal;
    FMax: Cardinal;
    FTimeOut: Cardinal;
    FLifeTime: Cardinal;
    FMaxTime: Cardinal;
  protected
    procedure AssignTo(Dest: TPersistent); override;
  public
    constructor Create;
    function Equals(PoolOptions: TLXResourcePoolOptions): Boolean;
  published
    property Enabled: Boolean read FEnabled write FEnabled default LX_DEFAULT_POOL_ENABLED;
    property Min: Cardinal read FMin write FMin default LX_DEFAULT_POOL_MIN;
    property Max: Cardinal read FMax write FMax default LX_DEFAULT_POOL_MAX;
    property TimeOut: Cardinal read FTimeOut write FTimeOut default LX_DEFAULT_POOL_TIME_OUT;
    property LifeTime: Cardinal read FLifeTime write FLifeTime default LX_DEFAULT_POOL_LIFE_TIME;
    property MaxTime: Cardinal read FMaxTime write FMaxTime default LX_DEFAULT_POOL_MAX_TIME;
  end;


{ TLXPoolResourceFactory }

  TLXPoolResourceFactory = class
  public
    procedure Release; virtual; abstract;
    function Equals(Params: TLXPoolResourceFactory): Boolean; virtual; abstract;
    function CreateClone: TLXPoolResourceFactory; virtual; abstract;
    function CreateResource(const AcquireParams: array of const;
      Collector: TLXResourceCollector): TLXResource; virtual; abstract;
    function PoolOptions: TLXResourcePoolOptions; virtual; abstract;
  end;


{ TLXResourceBase }

  TLXResourceBase = class(TLXResource)
  private
    FCollector: TLXResourceCollector;
  protected
    procedure PrepareCollect; virtual; abstract;
  public
    constructor Create(Collector: TLXResourceCollector);
    procedure Release; override;
    property Collector: TLXResourceCollector read FCollector;
  end;


{ TLXResourcePoolShare }

  TLXResourcePool = class;

  TLXResourcePoolShare = class
  private
    FRefCount: Integer;
    FSync: TCriticalSection;
    FDisabled: Boolean;
    FLockCount: Integer;
    FPool: TLXResourcePool;
  public
    constructor Create(Pool: TLXResourcePool);
    destructor Destroy; override;
    procedure AddRef;
    procedure Release;
    function Lock: Boolean;
    function Unlock: Boolean;
    procedure Disable;
    property Pool: TLXResourcePool read FPool;
  end;


{ TLXResoucePoolEntry }

  TLXResoucePoolEntry = class(TLXResourceCollector)
  private
    FPoolShare: TLXResourcePoolShare;
    FResource: TLXResource;
    FReleaseTime: Cardinal;
  public
    constructor Create(PoolShare: TLXResourcePoolShare);
    destructor Destroy; override;
    procedure CollectResource; override;
    property Resource: TLXResource read FResource write FResource;
    property ReleaseTime: Cardinal read FReleaseTime;
  end;


{ TLXPoolCleanerThread }

  TLXPoolCleanerThread = class(TThread)
  private
    FPool: TLXResourcePool;
    FStop: TEvent;
  public
    constructor Create(Pool: TLXResourcePool);
    destructor Destroy; override;
    procedure Execute; override;
  end;


{ TLXResourcePool }

  TLXResourcePoolStats = record
    Exists: Boolean;
    IdleCount: Cardinal;
    BusyCount: Cardinal;
    PeakCount: Cardinal;
  end;

  TLXResourcePool = class
  private
    FShare: TLXResourcePoolShare;
    FDeleting: TEvent;
    FUnlocked: TEvent;
    FResourceFactory: TLXPoolResourceFactory;
    FSync: TCriticalSection;
    FIdleEntries: TList;
    FSemaphore: THandle;
    FBusyEntryCount: Cardinal;
    FCleanerThread: TLXPoolCleanerThread;
    FPeakEntryCount: Cardinal;
    function CreatePoolEntry(const AcquireParams: array of const): TLXResoucePoolEntry;
    procedure ReleaseEntry(Entry: TLXResoucePoolEntry);
    function ReleaseIdleEntries: Cardinal;
    function Options: TLXResourcePoolOptions;
    procedure SetUnlocked;
    procedure WaitUnlock;
    class function GetEmptyStats: TLXResourcePoolStats;
  public
    constructor Create(ResourceFactory: TLXPoolResourceFactory);
    destructor Destroy; override;
    function AllocateResource(const AcquireParams: array of const): TLXResource;
    function Lock: Boolean;
    function Unlock: Boolean;
    function GetStats: TLXResourcePoolStats;
    property ResourceFactory: TLXPoolResourceFactory read FResourceFactory;
  end;


{ TLXResourcePools }

  TLXResourcePools = class
  private
    FPools: TList;
    FSync: TCriticalSection;
  public
    constructor Create;
    destructor Destroy; override;
    function AllocateResource(ResourceFactory: TLXPoolResourceFactory;
      const AcquireParams: array of const): TLXResource;
    function GetPoolStats(ResourceFactory: TLXPoolResourceFactory): TLXResourcePoolStats;
    procedure DeletePool(ResourceFactory: TLXPoolResourceFactory;
      AsyncDelete: Boolean);
    procedure DeletePools(AsyncDelete: Boolean);
  end;
  

implementation

uses LXConsts, LXSysUtils;


{ TLXResourcePoolOptions }

constructor TLXResourcePoolOptions.Create;
begin
  inherited;
  FEnabled := LX_DEFAULT_POOL_ENABLED;
  FMin := LX_DEFAULT_POOL_MIN;
  FMax := LX_DEFAULT_POOL_MAX;
  FTimeOut := LX_DEFAULT_POOL_TIME_OUT;
  FLifeTime := LX_DEFAULT_POOL_LIFE_TIME;
  FMaxTime := LX_DEFAULT_POOL_MAX_TIME;
end;

procedure TLXResourcePoolOptions.AssignTo(Dest: TPersistent);
begin
  if not (Dest is TLXResourcePoolOptions) then
    inherited AssignTo(Dest) else
  begin
    TLXResourcePoolOptions(Dest).FEnabled := FEnabled;
    TLXResourcePoolOptions(Dest).FMin := FMin;
    TLXResourcePoolOptions(Dest).FMax := FMax;
    TLXResourcePoolOptions(Dest).FTimeOut := FTimeOut;
    TLXResourcePoolOptions(Dest).FLifeTime := FLifeTime;
    TLXResourcePoolOptions(Dest).FMaxTime := FMaxTime;
  end;
end;

function TLXResourcePoolOptions.Equals(PoolOptions: TLXResourcePoolOptions): Boolean;
begin
  Result := (FEnabled = PoolOptions.FEnabled) and (FMin = PoolOptions.FMin) and
    (FMax = PoolOptions.FMax) and (FTimeOut = PoolOptions.FTimeOut) and
    (FLifeTime = PoolOptions.FLifeTime) and (FMaxTime = PoolOptions.FMaxTime);
end;


{ TLXResourceBase }

constructor TLXResourceBase.Create(Collector: TLXResourceCollector);
begin
  inherited Create;
  FCollector := Collector;
end;

procedure TLXResourceBase.Release;
begin
  if FCollector = nil then
    Destroy else
  begin
    PrepareCollect;
    FCollector.CollectResource;
  end;
end;


{ TLXResourcePoolShare }

constructor TLXResourcePoolShare.Create(Pool: TLXResourcePool);
begin
  FRefCount := 1;
  FSync := TCriticalSection.Create;
  FPool := Pool;
end;

destructor TLXResourcePoolShare.Destroy;
begin
  FSync.Free;
end;

procedure TLXResourcePoolShare.AddRef;
begin
  InterlockedIncrement(FRefCount);
end;

procedure TLXResourcePoolShare.Release;
begin
  if InterlockedDecrement(FRefCount) = 0 then Destroy;
end;

function TLXResourcePoolShare.Lock: Boolean;
begin
  FSync.Enter;
  Result := not FDisabled or (FLockCount > 0);
  if Result then Inc(FLockCount);
  FSync.Leave;
end;

function TLXResourcePoolShare.Unlock: Boolean;
begin
  FSync.Enter;
  Dec(FLockCount);
  Result := (FLockCount = 0) and FDisabled;
  FSync.Leave;
  if Result then FPool.SetUnlocked;
end;

procedure TLXResourcePoolShare.Disable;
var
  HasLocks: Boolean;
begin
  FSync.Enter;
  FDisabled := True;
  HasLocks := FLockCount > 0;
  FSync.Leave;
  if HasLocks then FPool.WaitUnlock;
end;


{ TLXResoucePoolEntry }

constructor TLXResoucePoolEntry.Create(PoolShare: TLXResourcePoolShare);
begin
  FPoolShare := PoolShare;
  PoolShare.AddRef;
end;

destructor TLXResoucePoolEntry.Destroy;
begin
  try
    FResource.Free;
  except
  end;
  FPoolShare.Release;
end;

procedure TLXResoucePoolEntry.CollectResource;
begin
  if not FPoolShare.Lock then
    Destroy else
  begin
    try
      FReleaseTime := GetTickCount;
      FPoolShare.Pool.ReleaseEntry(Self);
    finally
      FPoolShare.Unlock;
    end;
  end;
end;


{ TLXPoolCleanerThread }

constructor TLXPoolCleanerThread.Create(Pool: TLXResourcePool);
begin
  FPool := Pool;
  FStop := TEvent.Create(nil, True, False, '');
  inherited Create(False);
end;

destructor TLXPoolCleanerThread.Destroy;
begin
  if not Terminated then FStop.SetEvent;
  FStop.Free;
  inherited;
end;

procedure TLXPoolCleanerThread.Execute;
var
  TimeToSleep: Cardinal;
begin
  try
    TimeToSleep := FPool.ReleaseIdleEntries;
    while not Terminated do
    begin
      if FStop.WaitFor(TimeToSleep) = wrSignaled then Exit;
      TimeToSleep := FPool.ReleaseIdleEntries;
    end;
  except
  end;
end;


{ TLXResourcePool }

constructor TLXResourcePool.Create(ResourceFactory: TLXPoolResourceFactory);
begin
  inherited Create;
  FShare := TLXResourcePoolShare.Create(Self);
  FDeleting := TEvent.Create(nil, True, False, '');
  FUnlocked := TEvent.Create(nil, True, False, '');
  FResourceFactory := ResourceFactory.CreateClone;
  FSync := TCriticalSection.Create;
  FIdleEntries := TList.Create;
  FSemaphore := CreateSemaphore(nil, Options.Max, Options.Max, nil);
  if FSemaphore = 0 then
    LXRaiseLastOSError;
end;

destructor TLXResourcePool.Destroy;
var
  I: Integer;
begin
  if FShare <> nil then
  begin
    FShare.Disable;
    FShare.Release;
  end;
  FCleanerThread.Free;
  FDeleting.Free;
  FUnlocked.Free;
  FResourceFactory.Release;
  FSync.Free;
  if FIdleEntries <> nil then
  begin
    for I := 0 to FIdleEntries.Count - 1 do
      TLXResoucePoolEntry(FIdleEntries[I]).Free;
    FIdleEntries.Free;
  end;
  if FSemaphore <> 0 then
    CloseHandle(FSemaphore);
  inherited;
end;

function TLXResourcePool.AllocateResource(const AcquireParams: array of const): TLXResource;
var
  Entry: TLXResoucePoolEntry;
  WaitHandles: array [0..1] of THandle;
  WaitResult: DWORD;
begin
  WaitHandles[0] := FDeleting.Handle;
  WaitHandles[1] := FSemaphore;
  WaitResult := WaitForMultipleObjects(2, @WaitHandles, False, Options.TimeOut);
  if WaitResult = WAIT_TIMEOUT then
    raise ELXResourceException.Create(SPoolTimeOut);
  if WaitResult = WAIT_OBJECT_0 then
    raise ELXResourceException.Create(SPoolDeleting);

  FSync.Enter;
  try
    if FIdleEntries.Count = 0 then
      Entry := nil else
    begin
      Entry := FIdleEntries.First;
      FIdleEntries.Delete(0);
    end;
    Inc(FBusyEntryCount);
    if FBusyEntryCount > FPeakEntryCount then
      FPeakEntryCount := FBusyEntryCount;
  finally
    FSync.Leave;
  end;

  { Create the new resource entry outside the critical section because creation
    can take a long time and there is no need to lock the pool all this time }
  if Entry <> nil then
    try
      Entry.Resource.Acquire(AcquireParams);
  	except
      FreeAndNil(Entry);
  	end;

  try
    if Entry = nil then
      Entry := CreatePoolEntry(AcquireParams);
  except
    FSync.Enter;
    try
      Dec(FBusyEntryCount);
    finally
      FSync.Leave;
    end;
    if not ReleaseSemaphore(FSemaphore, 1, nil) then
      LXRaiseLastOSError;
    raise;
  end;

  Result := Entry.Resource;
end;

function TLXResourcePool.Lock: Boolean;
begin
  Result := FShare.Lock;
end;

function TLXResourcePool.Unlock: Boolean;
begin
  Result := FShare.Unlock;
end;

function TLXResourcePool.GetStats: TLXResourcePoolStats;
begin
  Result.Exists := True; 
  FSync.Enter;
  try
    Result.IdleCount := Cardinal(FIdleEntries.Count);
    Result.BusyCount := FBusyEntryCount;
    Result.PeakCount := FPeakEntryCount;
  finally
    FSync.Leave;
  end;
end;

function TLXResourcePool.CreatePoolEntry(const AcquireParams: array of const): TLXResoucePoolEntry;
begin
  Result := TLXResoucePoolEntry.Create(FShare);
  try
    Result.Resource := FResourceFactory.CreateResource(AcquireParams, Result);
  except
    Result.Free;
    raise;
  end;
end;

procedure TLXResourcePool.ReleaseEntry(Entry: TLXResoucePoolEntry);

  procedure CheckCleanerThread;
  begin
    if FCleanerThread = nil then
      FCleanerThread := TLXPoolCleanerThread.Create(Self)
    else if FCleanerThread.Terminated then
    begin
      FreeAndNil(FCleanerThread);
      FCleanerThread := TLXPoolCleanerThread.Create(Self);
    end;
  end;

var
  TotalEntryCount: Cardinal;
begin
  FSync.Enter;
  try
    Dec(FBusyEntryCount);
    FIdleEntries.Add(Entry);
    TotalEntryCount := Cardinal(FIdleEntries.Count) + FBusyEntryCount;
    if TotalEntryCount > Options.Min then
    begin
      if Options.LifeTime = 0 then
      begin
        Entry := FIdleEntries.First;
        FIdleEntries.Delete(0);
      end else
      begin
        Entry := nil;
        CheckCleanerThread;
      end;
    end else
    begin
      Entry := nil;
      if Options.MaxTime > 0 then
        CheckCleanerThread;
    end;
  finally
    FSync.Leave;
  end;
  { Free the resource entry outside the critical section because freeing can
    take a long time and there is no need to lock the pool all this time }
  Entry.Free;
  if not ReleaseSemaphore(FSemaphore, 1, nil) then
    LXRaiseLastOSError;
end;

function TLXResourcePool.ReleaseIdleEntries: Cardinal;
var
  EntriesToFree: TList;
  MinIdleEntryCount: Cardinal;
  EntryCountToHold: Cardinal;
  Entry: TLXResoucePoolEntry;
  I: Integer;
begin
  Result := 0;

  EntriesToFree := TList.Create;
  FSync.Enter;
  try
    if FBusyEntryCount < Options.Min then
      MinIdleEntryCount := Options.Min - FBusyEntryCount else
      MinIdleEntryCount := 0;
    if Options.MaxTime = 0 then
      EntryCountToHold := MinIdleEntryCount else
      EntryCountToHold := 0;

    while Cardinal(FIdleEntries.Count) > EntryCountToHold do
    begin
      Entry := FIdleEntries.First;

      Result := GetTickCount - Entry.ReleaseTime;

      if Cardinal(FIdleEntries.Count) > MinIdleEntryCount then
      begin
        if Result < Options.LifeTime then
        begin
          Result := Options.LifeTime - Result;
          Break;
        end;
      end else
        if Result < Options.MaxTime then
        begin
          Result := Options.MaxTime - Result;
          Break;
        end;

      FIdleEntries.Delete(0);
      EntriesToFree.Add(Entry);

      Result := 0;
    end;

    if Result = 0 then
      FCleanerThread.Terminate;
  finally
    FSync.Leave;
    { Free resource entries outside the critical section because freeing can
      take a long time and there is no need to lock the pool all this time }
    for I := 0 to EntriesToFree.Count - 1 do
      TLXResoucePoolEntry(EntriesToFree[I]).Free;
    EntriesToFree.Free;
  end;
end;

function TLXResourcePool.Options: TLXResourcePoolOptions;
begin
  Result := FResourceFactory.PoolOptions;
end;

procedure TLXResourcePool.SetUnlocked;
begin
  FUnlocked.SetEvent;
end;

procedure TLXResourcePool.WaitUnlock;
begin
  FDeleting.SetEvent;
  FUnlocked.WaitFor(INFINITE);
end;

class function TLXResourcePool.GetEmptyStats: TLXResourcePoolStats;
begin
  Result.Exists := False;
  Result.IdleCount := 0;
  Result.BusyCount := 0;
  Result.PeakCount := 0;
end;


{ TLXResourcePools }

constructor TLXResourcePools.Create;
begin
  inherited;
  FPools := TList.Create;
  FSync := TCriticalSection.Create;
end;

destructor TLXResourcePools.Destroy;
var
  I: Integer;
begin
  if FPools <> nil then
  begin
    for I := 0 to FPools.Count - 1 do
      TLXResourcePool(FPools[I]).Free;
    FPools.Free;
  end;
  FSync.Free;
  inherited;
end;

function TLXResourcePools.AllocateResource(ResourceFactory: TLXPoolResourceFactory;
  const AcquireParams: array of const): TLXResource;
var
  Pool: TLXResourcePool;

  function AllocatePool: TLXResourcePool;
  var
    I: Integer;
  begin
    for I := 0 to FPools.Count - 1 do
    begin
      Result := TLXResourcePool(FPools[I]);
      if ResourceFactory.Equals(Result.ResourceFactory) then Exit;
    end;
    Result := TLXResourcePool.Create(ResourceFactory);
    FPools.Add(Result);
  end;

begin
  FSync.Enter;
  try
    Pool := AllocatePool;
    Pool.Lock;
  finally
    FSync.Leave;
  end;
  try
    Result := Pool.AllocateResource(AcquireParams);
  finally
    Pool.Unlock;
  end;
end;

function TLXResourcePools.GetPoolStats(ResourceFactory: TLXPoolResourceFactory): TLXResourcePoolStats;
var
  I: Integer;
  Pool: TLXResourcePool;
begin
  FSync.Enter;
  try
    for I := 0 to FPools.Count - 1 do
    begin
      Pool := TLXResourcePool(FPools[I]);
      if ResourceFactory.Equals(Pool.ResourceFactory) then
      begin
        Result := Pool.GetStats;
        Exit;
      end;
    end;
    Result := TLXResourcePool.GetEmptyStats;
  finally
    FSync.Leave;
  end;
end;

procedure TLXResourcePools.DeletePool(ResourceFactory: TLXPoolResourceFactory;
  AsyncDelete: Boolean);
var
  Pool: TLXResourcePool;

  function DeletePool: TLXResourcePool;
  var
    I: Integer;
  begin
    for I := 0 to FPools.Count - 1 do
    begin
      Result := TLXResourcePool(FPools[I]);
      if ResourceFactory.Equals(Result.ResourceFactory) then
      begin
        if AsyncDelete then
          FPools.Delete(I) else
        begin
          Result.Free;
          FPools.Delete(I);
          Result := nil;
        end;
        Exit;
      end;
    end;
    Result := nil;
  end;

begin
  FSync.Enter;
  try
    Pool := DeletePool;
  finally
    FSync.Leave;
  end;
  if Pool <> nil then
    Pool.Free;
end;

procedure TLXResourcePools.DeletePools(AsyncDelete: Boolean);
var
  I: Integer;
  Pools: TList;
begin
  if AsyncDelete then
  begin
    Pools := TList.Create;
    try
      FSync.Enter;
      try
        Pools.Capacity := FPools.Count;
        for I := 0 to FPools.Count - 1 do
          Pools.Add(FPools[I]);
        FPools.Clear;
      finally
        FSync.Leave;
      end;
      for I := 0 to Pools.Count - 1 do
        TLXResourcePool(Pools[I]).Free;
    finally
      Pools.Free;
    end;
  end else
  begin
    FSync.Enter;
    try
      for I := FPools.Count - 1 downto 0 do
      begin
        TLXResourcePool(FPools[I]).Free;
        FPools.Delete(I);
      end;
    finally
      FSync.Leave;
    end;
  end;
end;


end.